home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / Module source / docmod < prev    next >
Encoding:
Text File  |  1994-10-09  |  15.3 KB  |  542 lines  |  [TEXT/YERK]
  1. \ 12.25.93    rfl    added need; fwind now moved out of way and dwind selected
  2. \  1.03.94    rfl    fixed copy, paste etc.
  3. \  9.30.94    rfl    no longer move fwind
  4.  
  5. :module docmod
  6.  
  7. // ctl
  8. // ctlwind
  9. // vscroll
  10. // textedit
  11.  
  12. 0 value eop
  13.  
  14. : getWidth    option?
  15.     IF -1 -> eop ELSE getvrect: actw drop 15 - 6 / 20 / 20 * 21 - -> eop 2drop THEN ;
  16.  
  17.  
  18. : (marks) ( cfa filemk --)
  19.     over @ = IF  >name dup
  20.                   8 .r  3 spaces n>count type out eop >
  21.                   IF cr 0 -> out ELSE 26 out over mod - spaces THEN
  22.              ELSE drop
  23.              THEN ?pause ;
  24.  
  25. \ same as 'words'..lists all filemarks
  26. \ hold down option key to get single column
  27. : marks  getWidth 0 -> out
  28.     base >r hex
  29.     'c (marks) filemk trav cr
  30.     r> -> base ; 
  31.  
  32.  
  33. 0 value mkCfa    \ the file mark cfa
  34.  
  35. \ define a word to check each cfa in the fmark vocab, and if it is earlier
  36. \  in the dictionary than the cfa of the word we are testing to see which
  37. \  file it is in, then we must have found the mark...set a flag.
  38. : (findMk)    \ ( cfa wordcfa -- )  
  39.            over > IF dup  -> mkCfa @ filemk = -> endTrav? ELSE drop THEN ;
  40.     
  41. \ find first mark above the wordcfa - returns true if mark found
  42. : findFMark    \ ( wordcfa -- cfa t or f)        - could also be addr
  43.     LoCase
  44.     'c (findMk)  swap trav
  45.     UpCase
  46.     endTrav? IF mkCfa true ELSE false THEN ;
  47.  
  48. \ get source name from mark
  49. : srcName  ( cfa -- addr len) findFMark not abort" No Mark"
  50.      >name n>count  ;
  51.  
  52. : (forget) ( pfa --)    dup nfa >line -> dp lfa @ current ! ;
  53.  
  54. : mforget LoCase [compile] ' (forget) Upcase ;
  55.  
  56. \ forget to last mark
  57. : FM here findFMark 0= abort" no mark found"
  58.      >body (forget) ;
  59.  
  60.  
  61. \ reload last file, forgetting to mark
  62. : RL here srcname fm new: loadfile
  63.     name: topfile interpret: topfile remove: loadfile ;
  64.  
  65. \ *** scrap stuff
  66. \ get next char from the scrap
  67. : scrapKey
  68.     next: parmStr 0=
  69.     IF rekey 13 THEN ;    \ simulate a terminal cr
  70.  
  71. : yy cr ok
  72.     BEGIN  ?dp
  73.         query interpret state 0=
  74.         IF  ok
  75.             where: parmstr size: parmstr =
  76.         ELSE ]> false
  77.         THEN
  78.     UNTIL ;
  79.  
  80. \ interpret from the scrap
  81. : yDoit start: parmStr 'c scrapKey -> keyVec  yy ;
  82.  
  83. \ *** reload sources from named mark
  84.  
  85. string LoadList    \ make the filelist here
  86. string tempStr    \ use in place of parmstr, since parmstr defined in Frontend
  87.  
  88. \ identify all source names from latest to the entered mark and fill filelist
  89. : (files) ( cfa cfa0 --)
  90.     over <=
  91.     IF dup @ filemk =
  92.         IF " // " put: tempStr >name n>count add: tempStr  13 +: tempStr lock: tempStr
  93.            get: tempStr start: LoadList insert: LoadList unlock: tempStr
  94.         ELSE drop THEN
  95.     ELSE drop true -> endTrav?
  96.     THEN ;
  97.  
  98. \ find filenames
  99. : files ( -- pfa) new: tempStr
  100.     clear: LoadList 'c (files) locase [compile] ' dup >r upcase 4- latest (trav) r>
  101.     release: tempStr ;
  102.  
  103. : loadKey
  104.     next: LoadList 0=
  105.     IF rekey 13 THEN ;    \ simulate a terminal cr
  106.  
  107. \ interpret from the scrap
  108. : Doit size: loadlist 0>
  109.     IF start: loadlist 'c loadKey -> keyVec  THEN sp! mp! quit ;
  110.  
  111. \ interpret LoadList
  112. : reload loadKey doit ;
  113.  
  114.  
  115. \ make file list, forget to the mark, and the reload the list.
  116. \ usage:  /// filename
  117. \ will rebuild from 'filename' to latest
  118. : /// new: LoadList files (forget) reload release: LoadList ;
  119.  
  120. : toScrap 0 call zeroScrap
  121.         global teScrpLength w@ 'type TEXT global teScrpHandle @ >ptr +base
  122.         call putScrap drop ;
  123.  
  124. : fromScrap 0 global TeScrpHandle @ 'type TEXT 0 call getScrap
  125.         dup 0 >= IF global TeScrpLength w! THEN ;
  126.  
  127. \ 1.31.92    rfl    modified recalscroll
  128. \ DISABLE MESSAGE SENT AFTER CLOSED!!!
  129.  
  130. \ class that is only for displaying scrolling, word wrapped text
  131. \  has a vertical scroll bar attached at right, with grow box.
  132. \  scroll region is entire window minus the scroll bar
  133. :CLASS TeScrollRect <super TextEdit
  134.  
  135.     var        myVScroll        \ scrollbar ptr
  136.     rect    boundsRect        \ turns out is content region 
  137.     int        atLine            \ internal use for keeping text at same line after grow
  138.     var        myWindow        \ used to determine if window is active for scroll bar
  139.     int        autoView        \ true if want autoView
  140.     var        myClikLoop        \ use for handling scroll bar while autoscrolling
  141.  
  142.   :M putScroll: ( n --) put: myVScroll ;M
  143.   :M setautoView: ( n --) put: autoView ;M
  144.   :M putClikLoop: ( cfa --) dup IF >body THEN put: myClikLoop ;M
  145.  
  146.   :M lineHeight: ( -- n) m@ >ptr 24 + w@ ;M
  147.   :M nlines: ( -- n) m@ >ptr 94 + w@ ;M
  148.  
  149.   :M putLine: ( n --) put: atLine ;M
  150.  
  151. \ returns top line
  152.   :M where: ( -- line#)  getTopY: destrect    \ subtract y0 of original dest rect    
  153.     m@ >ptr getTopY: rect - lineHeight: self / ;M    \ get y0 of internal dest rect
  154.  
  155. \  :M topChar: m@ >ptr 96 + where: self 2* + w@ ;M
  156.  
  157. \ get number of whole lines
  158.   :M visibleLines: ( -- n) ptr: self 8+ size: rect swap drop lineheight: self / ;M
  159.  
  160. \ boundsRect of two textctls can't be too close vertically: > 4 pixels 
  161.   :M putRect: { l t r b  -- } l t r b put: boundsRect
  162.     l 4+ t 2+ r 18 - b 2-  putRect: super m@
  163.     IF get: destRect drop over visibleLines: self lineHeight: self * +
  164.         ptr: self 8+ put: rect
  165.     THEN ;M
  166.  
  167. \ return max first line
  168.   :M maxRange: ( -- n) nlines: self visibleLines: self -  1+ ;M
  169.  
  170.   :M new: { myWind -- } myWind put: myWindow
  171.     myWind new: super
  172.     getBotX: boundsRect 15 - getTopY: boundsRect
  173.     size: boundsRect swap drop myWind new: [ obj: myVScroll ]
  174.     disable: [ obj: myVScroll ]
  175.     1 1 putRange: [ obj: myVScroll ]
  176.     get: autoView autoView: self
  177.     get: myClikLoop -dup IF +base ptr: self 42 + ! THEN ;M
  178.  
  179.   :M close: close: [ obj: myVScroll ] close: super 'c docmod munlock ;M
  180.  
  181.   :M draw: pushPort set: [ obj: myWindow ] draw: super popPort ;M
  182.  
  183. \ move text record to line# as first line in rect
  184.   :M moveto: { line# \ y -- } 0
  185.     line#  maxRange: self 1- min 0 max \ negate  \ where we want it to be
  186.     where: self                                \ where are we now?
  187.     - lineHeight: self * negate                \ translate to pixel offset
  188.     m@ >ptr offset: rect line# put: atLine draw: self
  189.     where: self 1+ put: [ obj: myVScroll ] ;M
  190.  
  191. \ recalibrate scroll bar size, range, and set text
  192.   :M recalScroll: 1 maxRange: self 1 max
  193.     putRange: [ obj: myVScroll ]
  194.     nlines: self visibleLines: self > active: [ obj: myWindow ] and
  195.     IF enable: [ obj: myVScroll ] THEN
  196.      get: atLine maxRange: self 1- min 0 max moveto: self            \ stay at about where we were before grow
  197.       ;M
  198.     
  199.   :M find: { addr len \ myText offset off1 -- offset line T or F }
  200.         heap> sarray -> myText new: myText 13 putChar: mytext
  201.         getText: super place: myText
  202.         start: myText addr len myText indexof: string
  203.         IF 1- -> offset
  204.              ptr: myText offset + bl parse -> off1 drop
  205.              bl parse offset + off1 + offset swap setSelect: self 2drop
  206.             limit: myText 1
  207.             DO offset i ^elem: myText 0 ^elem: myText - <
  208.                 IF i leave THEN
  209.             LOOP 1- 0 max moveto: self recalscroll: self
  210.         THEN release: myText dispose> myText ;M
  211.  
  212. \ recal really slows things down
  213.   :M addText: ( addr len --) addtext: super recalScroll: self ;M
  214.  
  215.   :M put: ( addr len --) clear: super addText: self ;M
  216.  
  217.   :M grow: ( l t r b -- ) where: self put: atLine
  218.      putRect: self
  219.     16 size: boundsRect swap drop 15 - size: [ obj: myVScroll ]
  220.     getBotX: boundsRect 15 - getTopY: boundsRect moveto: [ obj: myVScroll ]
  221.     recal: self
  222.     recalScroll: self ( draw: self)  ;M
  223.  
  224.   :M activate: activate: super enable: [ obj: myVScroll ] ;M
  225.   :M deactivate: deactivate: super disable: [ obj: myVScroll ] ;M
  226. \  :M exec: activate: self click: super ;M
  227.  
  228.   :M -findCR: { addr \ addr0 -- addr' }
  229.         getText: self drop -> addr0
  230.         BEGIN addr c@ 13 <> addr addr0 >= and
  231.         WHILE -1 ++> addr
  232.         REPEAT
  233.         1 ++> addr
  234.         addr ;M
  235.  
  236.   :M findCR: { addr \ addr0 -- addr' }
  237.         getText: self + -> addr0
  238.         BEGIN addr c@ 13 <> addr addr0 <= and
  239.         WHILE 1 ++> addr
  240.         REPEAT
  241.         -1 ++> addr
  242.         addr ;M
  243.  
  244. \ finds the selected text...if none, uses the line the carat is in
  245.   :M selection: { \ addr0 addr1 len -- addr len }
  246.          ptr: self 32 + @ unpack swap -> addr1 -> addr0
  247.          addr1 addr0 <>
  248.          IF addr1 addr0 - -> len
  249.             addr0 getText: self drop + -> addr0
  250.          ELSE addr0 getText: self drop + -> addr0
  251.               addr0 -findcr: self addr0 findcr: self -> addr1 -> addr0
  252.               addr1 addr0 - 1+ -> len
  253.          THEN addr0 len ;M
  254.  
  255.   :M click: click: super where: self 1+ put: [ obj: myVScroll ] ;M
  256.  
  257. ;CLASS
  258.  
  259. string undoBuf
  260.  
  261. \ class to contain the teScrollRect
  262. :CLASS ScrollWind <super ctlWind
  263.  
  264.     var     myTextPane    \ pointer to teScrollRect
  265. \    var     eventTime    \ click time that last event happened
  266.  
  267.   :M putPane: ( n --) put: myTextPane ;M
  268.  
  269.   :M close:  close: [ obj: myTextPane ] close: super ;M
  270.  
  271. \ draw only the grow box, no horizontal scroll lines
  272.   :M clipGrow: { \ b r scratchRgn -- } 
  273.     get: growFlg
  274.     IF 0 call NewRgn -> scratchRgn
  275.         scratchRgn call getClip
  276.         getRect: self 2swap 2drop -> b -> r
  277.         r 15 - 0 r b put: tempRect clip: tempRect
  278.         @xy (abs) call DrawGrowIcon gotoxy
  279.         scratchRgn call setClip scratchRgn call disposeRgn
  280.     THEN ;M
  281.  
  282. \ same draw as window, except that we clip the grow rect when drawing it.
  283.     :M  DRAW:    get: fPrect
  284.         (abs) call BeginUpdate
  285.         savePort @xy set: self
  286.         clipGrow: self
  287.         exec: draw    gotoxy    \ call user draw routine
  288.         (abs) call EndUpdate 
  289.         put: fPrect 
  290.         draw: [ obj: myTextPane ] restport ;M
  291.  
  292.     \ ( -- )  response to activate event - want to draw only grow rect
  293.     :M  ENABLE:  
  294.         ^base -> actW                \ commence idle handler
  295.         set: self
  296.         clipGrow: self
  297.         activate: [ obj: myTextPane ]
  298.         7 enable: editMen \ 1 enable: editMen 
  299.         exec: Enact ;M
  300.  
  301.   :M disable: deactivate: [ obj: myTextPane ]
  302.         0 -> actw clipGrow: self
  303.         7 disable: editMen ( 1 disable: editMen) exec: deact ;M
  304.  
  305.   :M (grow): getVrect: self put: temprect -4 0 offset: temprect clear: temprect
  306.         getrect: self 2+ swap 1+ swap put: temprect -1 -1 offset: temprect
  307.         get: temprect grow: [ obj: myTextPane ] ;M
  308.  
  309.  :M grow: Get: growFlg
  310.         IF     0 (abs) Where: fEvent  abs: growrect
  311.             call GrowWindow -dup
  312.             IF unpack size: self (grow): [ ^base ] setView: self THEN
  313.         THEN  select: self ;M
  314.  
  315.   :M new: alive: super not
  316.     IF new: super ^base new: [ obj: myTextPane ] 
  317.         setLimits: self \ activate: [ obj: myTextPane ]
  318.         (grow): [ ^base ]
  319.     THEN ( select: self) ;M
  320.  
  321.  
  322.   :M addText: ( addr len --) alive: self
  323.     IF pushPort >r set: self addText: [ obj: myTextPane ] r> popPort
  324.     ELSE 2drop
  325.     THEN ;M
  326.  
  327.   :M print: ( addr len --) alive: self
  328.     IF pushPort >r set: self put: [ obj: myTextPane ] r> popPort
  329.     ELSE 2drop
  330.     THEN ;M
  331.  
  332.   :M saveUndo: getText: [ obj: myTextPane ] put: undoBuf ;M
  333.  
  334.   :M cut:   saveUndo: self  teCut: [ obj: myTextPane ] toScrap ;M
  335.   :M copy:                   teCopy: [ obj: myTextPane ] toScrap ;M
  336.   :M paste: saveUndo: self fromScrap tePaste: [ obj: myTextPane ] ;M
  337.  
  338.   :M key: { char  -- }
  339.     char $ ff and -> char
  340.     char 3 =
  341.     IF selection: [ obj: myTextPane ] put: parmstr
  342.         set: fwind  ydoit set: self
  343.     ELSE char key: [ obj: myTextPane ]
  344.     THEN ;M
  345.  
  346.   :M undo: get: undoBuf putText: [ obj: myTextPane ] recalScroll: [ obj: myTextPane ] ;M
  347.  
  348.   :M content:
  349.     pushPort ^base set: grafPort ^base ctlhit? not
  350.     IF select: self click: [ obj: myTextPane ]
  351.     THEN  popPort ;M
  352.  
  353.   :M idle: ptIn: [ obj: myTextPane ]
  354.         IF ibeamCurs  ELSE arrowCurs THEN idle: [ obj: myTextPane ] exec: idle ;M
  355.  
  356.   :M selectAll: selectAll: [ obj: myTextPane ] recalscroll: [ obj: myTextPane ] ;M
  357.  
  358. ;CLASS
  359.  
  360. \ instantiate objects
  361. ScrollWind dwind
  362. tescrollrect dPane
  363. vscroll dscroll
  364. dscroll putScroll: dPane
  365. true setautoView: dPane
  366. dPane putPane: dwind
  367.  
  368. \ 2  2 270 120 putrect:    dPane
  369.  
  370. 270 61 640 300 true setgrow: dwind
  371.  
  372. : buildDWind pushPort alive: dwind not
  373.     IF  new: undoBuf
  374.         2 40 542 200 put: temprect
  375.         temprect 0 0 docwind false true new: dwind
  376.     THEN dup call selectWindow popPort
  377.     1 'c docmod 12 + @ $ ffffff and c! ;    \ force the module to be locked
  378.                                             \ until window is closed
  379.  
  380. : lndn get: dscroll 1+ dup put: dscroll maxRange: dPane <=
  381.     IF 0 lineHeight: dPane negate scroll: dPane THEN ;
  382. : lnup get: dscroll 1- dup put: dscroll  0>
  383.     IF 0 lineHeight: dPane  scroll: dPane THEN ;
  384. : pgdn get: dscroll visibleLines: dPane 1- + put: dscroll get: dscroll 1- moveto: dPane ;
  385. : pgup get: dscroll visibleLines: dPane 1- - put: dscroll get: dscroll 1- moveto: dPane ;
  386. : doth get: dscroll put: dscroll get: dscroll 1- moveto: dPane ;
  387.  
  388. 5 'cfas lnup lndn pgup pgdn doth actions: dscroll
  389.  
  390. 0 value srcOpen    \ store mkcfa or 0.
  391.  
  392. : NoSrc false -> srcOpen release: undoBuf become quit ;
  393.  
  394.  
  395. 0 value lastEvent
  396. 1 value doUndo
  397. : saveUndo getText: dpane put: undoBuf false -> doUndo ;
  398.  
  399. : dwindInterp  \ \ for testing textctl entries
  400.     drop
  401.     BEGIN
  402.         next: fevent
  403.         IF active: dwind
  404.             IF when: fevent lastEvent - 60 > doUndo and
  405.                 IF saveUndo
  406.                 ELSE true -> doUndo when: fevent -> lastEvent
  407.                 THEN
  408.                 drop key: dwind false ELSE drop true THEN
  409.         ELSE  false
  410.         THEN
  411.     UNTIL ;
  412.  
  413. \ : xx set: fwind mp! quit ;
  414. : xx set: fwind become quit ;
  415. 4 'cfas NoSrc dwindInterp null null actions: dwind
  416. 2 'cfas dwindInterp xx setAct: dwind
  417.  
  418. : loadr ( addr len --)
  419.     new: loadfile
  420.      name: topFile
  421.     open: topFile dup konstant fnfErr =
  422.     abort" file not in pathList"
  423.     abort" file error"
  424.     topFile size: topFile read: tempstr drop
  425.     builddwind
  426.     getName: topFile title: dwind
  427.     remove: loadfile   ;
  428.  
  429. : needMove { \ l t r b -- b }
  430.     set: dwind 0 l->g unpack -> t -> l
  431.     getrect: dwind t + -> b l + -> r 2drop
  432.     set: fwind 0 l->g unpack 20 - b < swap
  433.     r < and ;
  434.  
  435. : moveFwind { \ l t r b -- } needMove
  436.     IF  set: dwind 0 l->g unpack -> t drop
  437.         getRect: dwind ++> t drop 2drop
  438.         getRect: fwind -> b -> r 2drop
  439.         screenbits 20 - t b + min -> b drop 2drop
  440.         r b t -  size: fwind
  441.         2 t 20 + moveto: fwind set: fwind select: fwind
  442.         fixGrow: fwind
  443.     THEN enable: fwind ;
  444.     
  445. : see { \ xline wordPfa -- }
  446.     docs 0= abort" +docs not set"
  447.     @word count sfind
  448.     IF drop -> wordPfa
  449.         wordPfa nfa >line w@ extend -> xline
  450.         xline -1 <>
  451.         IF wordPfa findfmark
  452.             IF    srcOpen <>
  453.                 IF  new: tempStr
  454.                     mkCFA >name n>count loadr mkCFA -> srcOpen
  455.                      xline putLine: dpane
  456.                      lock: tempstr get: tempstr print: dwind unlock: tempstr
  457.                      release: tempstr 
  458.                 ELSE xline moveto: dpane
  459.                 THEN
  460.                 moveFwind show: dwind
  461.             ELSE ." word not marked"
  462.             THEN
  463.         ELSE ." word not marked"
  464.         THEN
  465.     ELSE ." not found"
  466.     THEN  ;
  467.  
  468. \ : qhit? ( n n - b) drop $ ff and ascii q = ;
  469. \ 
  470. \ \ for testing textctl entries
  471. \ : kk BEGIN
  472. \         next: fevent
  473. \         IF actw fwind =
  474. \             IF  qhit?
  475. \                 IF exit THEN
  476. \             ELSE drop key: actw
  477. \             THEN
  478. \         THEN
  479. \     AGAIN ;
  480.  
  481. \ *************************
  482.  
  483. hex    \ compare two strings case insensitive
  484. create s=' ( addr len addr len -- tf)
  485.     201f w,        \ move.l    (sp)+,d0
  486.     225f w,        \ movea.l    (sp)+,a1
  487.     241f w,        \ move.l    (sp)+,d2
  488.     2057 w,        \ movea.l    (sp),a0
  489.     4840 w,        \ swap        d0
  490.     3002 w,        \ move.w    d2,d0
  491.     4840 w,        \ swap        d0
  492.     d1cb w,        \ adda.l    a3,a0
  493.     d3cb w,        \ adda.l    a3,a1
  494.     a03c w,        \ call equalString
  495.     0a00 w, 1 w, \ eori.b    #1,d0
  496.     2e80 w,        \ move.l    d0,(sp)
  497. next,
  498. decimal
  499.  
  500. : (include) { cfa nameAddr -- }
  501.     cfa @ filemk =
  502.     IF cfa >name n>count str255 -base count
  503.         nameAddr count s=' -> endTrav?
  504.     THEN ;
  505.  
  506. : need { \ lcurs -- }
  507.     docs 0= abort" +docs not set"
  508.     new: loadfile setName: topfile
  509.     'c (include) getName: topfile drop 1- trav endTrav? not
  510.     IF  curs -> lcurs -curs                \ Preserve cursor status
  511.         getName: topFile  3 tfont 1 tface type# 173 ( Loading: ) type 0 tface 4 tfont cr
  512.         interpret: topFile
  513.         lcurs -> curs                     \ Restore cursor status
  514.     THEN remove: loadFile ;
  515.  
  516. \ : fixit cleanfloat actw dwind = IF set: dwind select: dwind 1 dwindInterp THEN ;
  517. \ 'c fixit -> abortvec
  518.  
  519. \ UNDER CONSTRUCTION
  520. \ empirically must  now call where: fevent or getBotY: rect...I wonder if it
  521. \   in yerk's :proc setup that won't allow some things. Also, why doesn't hilighting
  522. \   continue as we scroll up??
  523.  
  524. \ :proc huh 0 call newRgn >r
  525. \     ?terminal drop fevent 10 + @ g->l unpack swap drop dup 2 <
  526. \     IF drop 
  527. \         r call getClip getrect: dwind put: temprect clip: temprect
  528. \         lnup r call setClip
  529. \     ELSE dpane 28 + w@ 2- >
  530. \         IF r call getClip getrect: dwind put: temprect clip: temprect
  531. \             lndn r call setClip
  532. \         THEN
  533. \     THEN r> call disposeRgn ;proc
  534. \ 
  535. \ 'c huh putclikloop: dpane
  536.  
  537. \ 'c huh putclikloop: dpane
  538. true setAutoView: dpane
  539.  
  540.     
  541. ;module
  542.